home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / crawl.t < prev    next >
Text File  |  1988-05-02  |  16KB  |  420 lines
  1. (herald crawl (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; structure and stack crawler
  27.  
  28. (lset *crawl-env*   nil)
  29. (lset *crawl-stack* nil)
  30. (lset *crawl-quit*  nil)
  31. (lset *crawl-args*  nil)              
  32. (lset **cont** nil)
  33.  
  34. ;;; top-level entry for crawl.
  35.  
  36. (define (*crawl env . objects)
  37.   (catch quit
  38.          (bind ((*print-level* 4)
  39.                 (*print-length* 6)
  40.                 (*crawl-quit* quit)     ; only for benefit of q command
  41.                 (*crawl-stack* '())
  42.                 (*crawl-args* nil)
  43.                 (*crawl-env* env))
  44.            (walk crawl-push (reverse! objects))
  45.            (t-breakpoint-aux nil crawl-command-loop))))
  46.  
  47. ;;; prompt before reading new command line.
  48. ;;; don't prompt after an empty command line.
  49. ;;; do all commands read on one line.
  50.  
  51. (define (crawl-command-loop in out)
  52.   (iterate next-command-line ((previous *crawling-nothing*) (hack t))
  53.     (let ((obj (cond ((null? *crawl-stack*) *crawling-nothing*)
  54.                      (else (car *crawl-stack*)))))
  55.       (cond (hack
  56.              (cond ((neq? obj previous)
  57.                     (crawl-synopsis obj (out))))
  58.              (fresh-line (out))
  59.              (prompt (out) (crawl-prompt obj))))
  60.       (let ((line (read-line (in))))
  61.         (cond ((eof? line) repl-wont-print)       ; exit
  62.               (else
  63.                (let ((l (read-objects-from-string line)))
  64.                  (cond ((null? l)
  65.                         (next-command-line obj nil))
  66.                        (else
  67.                         (set *crawl-args* l)
  68.                         (iterate loop ()
  69.                           (cond ((null? *crawl-args*)
  70.                                  (next-command-line obj t))
  71.                                 (else
  72.                                  (let ((command (pop *crawl-args*))
  73.                                        (next (car *crawl-stack*)))
  74.                                    (cond ((get-crawl-command command)
  75.                                           => (lambda (z) (z next)))
  76.                                          ((maybe-crawl-component next command))
  77.                                          (else
  78.                                           (format (out) "illegal command.~%")))
  79.                                    (loop))))))))))))))
  80.  
  81. (define *crawling-nothing*
  82.   (object nil
  83.           ((crawl-synopsis self out) (ignore out) nil)  ; do nothing
  84.           ((identification self) '*crawling-nothing*)))
  85.  
  86. (define-operation (crawl-synopsis obj out)
  87.   (print-one-line obj out)
  88.   (fresh-line out)
  89.   (cond ((frame? obj) 
  90.          (frame-print-synopsis obj out))
  91.         ((unit? obj)
  92.          (format out " source = ~s  size = ~s"
  93.                  (unit-source-filename obj)
  94.                  (unit-length obj)))))
  95.  
  96. (define-operation (crawl-prompt obj)
  97.   (cond ((frame? obj) "debug: ")
  98.         (else         "crawl: ")))
  99.  
  100. ;;; predicate: returns true if a component with the given name was
  101. ;;; pushed.
  102.  
  103. (define-operation (maybe-crawl-component obj command)
  104.   (cond ((and (structure? obj)
  105.               (any (lambda (x) (if (eq? command (selector-id x)) x nil))
  106.                    (stype-selectors (structure-type obj))))
  107.          => (lambda (sel) (crawl-push (sel obj))))
  108.         ((frame? obj)
  109.          (maybe-crawl-frame-component obj command))
  110.         ((and (closure? obj) 
  111.               (not (template-internal-bit? (extend-header obj))))
  112.          (receive (pointer scratch) (closure-size-info obj)
  113.            (cond ((and (fixnum? command)
  114.                        (fx>= command 0)
  115.                        (fx< command pointer))
  116.                   (crawl-push (extend-pointer-elt obj command)))
  117.                  (else nil))))
  118.         (else nil)))
  119.                                                   
  120. ;;; horrible stuff for T3 frames
  121.  
  122. (define (maybe-crawl-frame-component frame command)
  123.   (if (and (fixnum? command) (fx>= command 0))
  124.       (let ((prev (previous-continuation frame)))
  125.         (iterate loop ((frame frame) (i 0))
  126.           (cond ((eq? frame prev) nil)  
  127.                 ((not (frame? frame))
  128.                  (loop (frame-previous frame) i))
  129.                 (else
  130.                  (receive (pointer scratch) (closure-size-info frame)
  131.                    (cond ((fx< command (fx+ i pointer))
  132.                           (crawl-push (extend-pointer-elt frame (fx- command i))))
  133.                          (else
  134.                           (loop (frame-previous frame) (fx+ i pointer)))))))))
  135.       nil))
  136.  
  137.  
  138. (define (crawl-exhibit-frame frame)
  139.   (let ((prev (previous-continuation frame)))
  140.     (iterate loop ((frame frame) (i 0))      
  141.       (cond ((eq? frame prev) t)
  142.             ((not (frame? frame))
  143.              (loop (frame-previous frame) i))
  144.             (else
  145.              (receive (pointer scratch) (closure-size-info frame)
  146.                (exhibit-standard-extend frame pointer scratch i)
  147.                (loop (frame-previous frame) (fx+ i pointer))))))))
  148.  
  149.  
  150.  
  151. ;;; the commands:
  152.  
  153. (define-local-syntax (define-crawl-command pat symbol doc . body)
  154.   `(block (define-operation ,pat . ,body)
  155.           (*define-crawl-command  ',symbol
  156.                                   ',doc
  157.                                   ,(car pat))
  158.           ',symbol))
  159.  
  160. (define (*define-crawl-command symbol doc op)
  161.   (let ((com (join op (object nil
  162.                        ((print-crawl-help self)
  163.                         (format (terminal-output) "  ~a  ~a~%" symbol doc))))))
  164.     (push *the-crawl-commands* com)
  165.     (set (table-entry *crawl-command-table* symbol)
  166.          com)))
  167.  
  168. (lset *the-crawl-commands* '())
  169.  
  170. (define *crawl-command-table* (make-table '*crawl-command-table*))
  171.  
  172. (define (get-crawl-command command)
  173.   (if (symbol? command) (table-entry *crawl-command-table* command) nil))
  174.  
  175. (define-operation (print-crawl-help obj))
  176.  
  177. (define-crawl-command (crawl-help obj) ?
  178.   "print summary of inspector commands."
  179.   (walk print-crawl-help *the-crawl-commands*)
  180.   (format (terminal-output)
  181.           " the a, c, and e commands will prompt for an expression.~%"))
  182.  
  183. (define-crawl-command (crawl-apply obj) a
  184.   "apply a procedure to the current object."
  185.   (let ((z (crawl-read "call what procedure? ")))
  186.     (cond ((eof? z) nil)
  187.           (else
  188.            (let ((proc (eval-in-crawled-env z obj)))
  189.              (cond ((procedure? proc)
  190.                     (receive-values crawl-receiver
  191.                                     (lambda () (proc obj))))
  192.                    (else
  193.                     (format (terminal-output) "~s is inapplicable.~%"
  194.                             proc))))))))
  195.  
  196. (define (crawl-receiver . vals)
  197.   (cond ((null? vals)
  198.          (format (terminal-output) "no values.~%"))
  199.         ((not (null? (cdr vals)))
  200.          (format (terminal-output)
  201.                  "~s values.  successive u commands will inspect them.~%"
  202.                  (length vals))))
  203.   (walk crawl-push (reverse! vals)))
  204.  
  205. (define-crawl-command (crawl-break obj) b
  206.   "enter a read-eval-print loop in an appropriate environment."
  207.   (let ((env (or (get-environment obj)
  208.                  (repl-env))))
  209.     (format (terminal-output)
  210.             "~&breakpoint in ~s~%  with *obj* = ~s~%"
  211.             env
  212.             obj)
  213.     (breakpoint nil
  214.                 (eval `((lambda (*obj*) (the-environment)) ',obj)
  215.                       env))))
  216.  
  217. (define-crawl-command (crawl-crawl obj) c
  218.   "inspect another object."
  219.   (let ((z (crawl-read "inspect what object? ")))
  220.     (cond ((not (eof? z))
  221.            (receive-values crawl-receiver
  222.                            (lambda () (eval-in-crawled-env z obj)))))))
  223.  
  224. (define-crawl-command (crawl-down obj) d
  225.   "go to next deeper continuation (i.e. stack frame)."
  226.   (cond ((frame? obj)
  227.          (let ((prev (previous-continuation obj)))
  228.            (cond ((null? prev)
  229.                   (format (terminal-output)
  230.                           "you are at the bottom of the stack.~%"))
  231.                  (else
  232.                   (crawl-push prev)))))
  233.         (else (bad-crawl-command))))
  234.                          
  235. (define-crawl-command (crawl-eval obj) e
  236.   "evaluate an expression in current object's environment."
  237.   (let ((z (crawl-read "evaluate what? ")))
  238.     (cond ((not (eof? z))
  239.            ((repl-print) (eval-in-crawled-env z obj) (terminal-output))
  240.            (newline (terminal-output))))))
  241.  
  242. (define (cont) (**cont** nil))
  243.  
  244. (define-crawl-command (crawl-return-and-save obj) k
  245.   "return a value to a continuation, and save debugger state."
  246.   (let ((really-return
  247.          (lambda (frame)
  248.            (let ((val (crawl-read "return what value? (eof to abort) ")))
  249.              (cond ((eof? val) nil)
  250.                    (else 
  251.                     (format t "Do (CONT) to return to debugger at this point.~%")
  252.                     (call-with-current-continuation 
  253.                      (lambda (k)
  254.                        (set **cont** k)
  255.                        (receive values (eval-in-crawled-env val obj)
  256.                          (frame-throw frame values))))))))))
  257.     (cond ((frame? obj)
  258.            (really-return obj))
  259.           ((escape-procedure? obj)
  260.            (really-return (escape-procedure-frame obj)))
  261.           (else
  262.            (format (terminal-output) "k is meaningless here.~%")))))
  263.  
  264.  
  265. (define-crawl-command (crawl-show-env obj) l
  266.   "list values of lexical variables out to nearest locale."
  267.   (crawl-exhibit-env (get-crawl-env obj)))
  268.  
  269. (define-operation (crawl-exhibit-env env)
  270.   (format (terminal-output) "no local variables.~%"))
  271.  
  272. (define-crawl-command (crawl-macro-expand obj) m
  273.   "macro-expand current object, and pretty-print the expansion."
  274.   (let ((x (macro-expand obj (env-syntax-table (get-crawl-env obj)))))
  275.     (crawl-pp x)
  276.     (crawl-push x)))
  277.  
  278. (define (crawl-pp obj)
  279.   (let ((out (terminal-output)))
  280.     (fresh-line out)
  281.     (pretty-print obj out)
  282.     (fresh-line out)))
  283.  
  284. (define-crawl-command (crawl-next obj) n
  285.   "go to next object on stack."
  286.   (let ((prev (frame-previous obj)))
  287.     (cond ((null? prev)
  288.            (format (terminal-output)
  289.                    "you are at the bottom of the stack.~%"))
  290.           (else
  291.            (crawl-push prev)))))
  292.  
  293.  
  294. (define-crawl-command (crawl-print obj) p
  295.   "pretty-print current object."
  296.   (crawl-pp (or (cond ((frame? obj) (frame-disclose obj))
  297.                       (else (disclose obj)))
  298.                 obj)))
  299.  
  300. (define-crawl-command (crawl-quit obj) q
  301.   "exit the inspector."
  302.   (*crawl-quit* repl-wont-print))
  303.  
  304. (define-crawl-command (crawl-return obj) r
  305.   "return a value to a continuation, continuing execution at that point."
  306.   (let ((really-return
  307.          (lambda (frame)
  308.            (let ((val (crawl-read "return what value? (eof to abort) ")))
  309.              (cond ((eof? val) nil)
  310.                    (else 
  311.                     (receive values (eval-in-crawled-env val obj)
  312.                       (frame-throw frame values))))))))
  313.     (cond ((frame? obj)
  314.            (really-return obj))
  315.           ((escape-procedure? obj)
  316.            (really-return (escape-procedure-frame obj)))
  317.           (else
  318.            (format (terminal-output) "r is meaningless here.~%")))))
  319.  
  320. (define-crawl-command (crawl-up obj) u
  321.   "go back to inspecting previous object."
  322.   (cond ((null? (cdr *crawl-stack*))
  323.          (format (terminal-output) "you can't go up from here.~%"))
  324.         (else
  325.          (pop *crawl-stack*))))
  326.  
  327. (define-crawl-command (crawl-to-unit obj) v
  328.   "inspect current object's unit (compiled module)."
  329.   (cond ((template? obj)
  330.          (crawl-push (template-unit obj)))
  331.         ((closure? obj)
  332.          (crawl-push (template-unit (extend-header obj))))
  333.         (else (bad-crawl-command))))
  334.  
  335. (define-crawl-command (crawl-where-defined obj) w
  336.   "give file name of current object's definition."
  337.   (format (terminal-output) "~s~%" (where-defined obj)))
  338.  
  339. (define-crawl-command (crawl-show obj) x
  340.   "display object's contents or other relevant information."
  341.   (crawl-exhibit obj))
  342.  
  343. (define-crawl-command (crawl-display obj) =
  344.   "print object, its hash, and its address."
  345.   (format (terminal-output) " ~s~_=~_~s~_=~_(~s #x~x)~2_<~s>~%"
  346.           obj
  347.           `(unhash ,(object-hash obj))
  348.           'fixnum->descriptor
  349.           (descriptor->fixnum obj)
  350.           (or (points-to-reasonable-memory obj)
  351.               'random)))
  352.  
  353. ;;; utilities.
  354.  
  355. (define (crawl-push obj)                ; must return true.
  356.   (push *crawl-stack* obj)
  357.   t)
  358.  
  359. (define (get-crawl-env obj)
  360.   (or (and (not (structure? obj)) (get-environment obj)) *crawl-env*))
  361.  
  362. ;;; careful!  this may return multiple values.
  363.  
  364. (define (eval-in-crawled-env form obj)
  365.   ;; if stack frame, we should bind the dynamic context, yes?
  366.   ((repl-eval) form (get-crawl-env obj)))
  367.  
  368. (define (crawl-read prmpt)
  369.   (cond ((null? *crawl-args*)
  370.          (prompt (terminal-output) prmpt)
  371.          (read (terminal-input)))
  372.         (else (pop *crawl-args*))))
  373.  
  374. ;;; the moby x command.
  375.  
  376. (define-operation (crawl-exhibit obj)
  377.   (cond ((not (closure? obj)) nil)
  378.         ((frame? obj)
  379.          (crawl-exhibit-frame obj))                      
  380.         ((template-internal-bit? (extend-header obj))
  381.          (format (terminal-output) '("Object is internal to a closure~a "
  382.                                      "the v command will inspect it~%") 
  383.                                    #\semicolon))  ; uluz 
  384.         (else
  385.          (receive (pointer scratch) (closure-size-info obj)
  386.            (exhibit-standard-extend obj pointer scratch 0)))))
  387.  
  388. (define (crawl-print-component selector obj)
  389.   (let ((out (terminal-output)))
  390.     (format out " [~s] " selector)
  391.     (print-one-line obj out)
  392.     (newline out)))
  393.  
  394. (define (exhibit-standard-extend obj ptr-size scr-size start)
  395.   (iterate loop ((i 0) (j start) (previous nil) (repeating? nil))
  396.     (cond ((fx>= i ptr-size)
  397.            (cond ((fx> scr-size 0)
  398.                   (if (fx> ptr-size 0) (format (terminal-output) " and"))
  399.                   (format (terminal-output) " ~s scratch slots~%" scr-size))))
  400.           (else
  401.            (let ((thing (extend-pointer-elt obj i)))
  402.              (cond ((or (neq? thing previous)
  403.                         (fx= i 0)
  404.                         (fx= i (fx- ptr-size 1)))
  405.                     (crawl-print-component j thing)
  406.                     (loop (fx+ i 1) (fx+ j 1) thing nil))
  407.                    ((not repeating?)
  408.                     (format (terminal-output) " ...~%")
  409.                     (loop (fx+ i 1) (fx+ j 1) thing t))
  410.                    (else
  411.                     (loop (fx+ i 1) (fx+ j 1) thing t))))))))
  412.  
  413. (define (bad-crawl-command)
  414.   (format (terminal-output)
  415.           "there is no way to go in that direction.~%"))
  416.  
  417. ;;; reverse command list for prettiness in help.
  418.  
  419. (set *the-crawl-commands* (reverse! *the-crawl-commands*))
  420.